home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / pcscheme / geneva / sources.exe / SAMPLES / CFRAC.S < prev    next >
Encoding:
Text File  |  1993-05-29  |  2.7 KB  |  95 lines
  1. (define (numerator quad)
  2.   (if (number? quad)
  3.       quad
  4.       (cadr quad)))
  5. (define (denominator quad)
  6.   (if (number? quad)
  7.       1
  8.       (caddr quad)))
  9. (define (int-part quad)
  10.   (let ((n (numerator quad)))
  11.     (if (number? n)
  12.     n
  13.     (cadr n))))
  14. (define (surd-part quad)
  15.   (let ((n (numerator quad)))
  16.     (if (number? n)
  17.     0
  18.     (car (cdaddr n)))))
  19. (define (surd quad)
  20.   (let ((n (numerator quad)))
  21.     (if (number? n)
  22.     0
  23.     (cadadr (cdaddr n)))))
  24. (define (make-frac num denom)
  25.   (let ((g (gcd num denom)))
  26.     (if (member (/ denom g) '(-1 1))
  27.     (/ num denom)
  28.     `(/ ,(/ num g) ,(/ denom g)))))
  29. (define (make-quad int-part surd-part surd denom)
  30.   (if (eq? surd-part 0)
  31.       (make-frac int-part denom)
  32.       (let ((g (gcd int-part surd-part denom)))
  33.     `(/ (+ ,(/ int-part g) (* ,(/ surd-part g) (sqrt ,surd)))
  34.         ,(/ denom g)))))
  35. (define (frac+ f g)
  36.   (make-frac (+ (* (denominator f) (numerator g))
  37.         (* (numerator g) (denominator f)))
  38.          (* (denominator f) (denominator g))))
  39. (define (frac- f . g)
  40.   (if (null? g)
  41.       (make-frac (- (numerator f)) (denomintaor f))
  42.       (frac+ f (frac- (car g)))))
  43. (define (frac* f g)
  44.   (make-frac (* (numerator f) (numerator g))
  45.          (* (denominator f) (denominator g))))
  46. (define (frac/ f g)
  47.   (make-frac (* (numerator f) (denominator g))
  48.          (* (denominator f) (* numerator g))))
  49.  
  50. (define (conjugate f)
  51.   (make-quad (int-part f) (- (surd-part f)) (surd f) (denominator f)))
  52. (define (norm f)
  53.   (quad* f (conjugate f)))
  54. (define (quad+ f g)
  55.   (let ((c (denominator f))
  56.     (d (denominator g)))
  57.     (make-quad (+ (* (int-part f) d) (* c (int-part g)))
  58.            (+ (* (surd-part f) d) (* c (surd-part g)))
  59.            (surd f)
  60.            (* c d))))
  61. (define (quad- f . g)
  62.   (if (null? g)
  63.       (make-quad (- (int-part f)) (- (surd-part f)) (surd f) (denominator f))
  64.       (quad+ f (quad- g))))
  65. (define (quad* f g)
  66.   (make-quad (+ (* (int-part f) (int-part g))
  67.         (* (surd-part f) (surd-part g) (surd f)))
  68.          (+ (* (int-part f) (surd-part g))
  69.         (* (surd-part f) (int-part g)))
  70.          (surd f)
  71.          (* (denominator f) (denominator g))))
  72. (define (quad/ f g)
  73.   (let ((q (quad* f (conjugate g)))
  74.     (n (norm g)))
  75.     (make-quad (* (int-part q) (denominator n))
  76.            (* (surd-part q) (denominator n))
  77.            (surd q)
  78.            (* (denominator q) (numerator n)))))
  79.  
  80. (define (frac->quadratic frac)
  81.   (if (null? (cdr frac))
  82.       (car frac)
  83.       (if (list? (car frac))
  84.       1
  85.       (quad+ (car frac) (quad/ 1 (frac->quadratic (cdr frac)))))))
  86.  
  87. (define (frac->number frac)
  88.   (if (null? (cdr frac))
  89.       (car frac)
  90.       (if (list? (car frac))                ; a period
  91.       (eval (frac->quadratic frac))
  92.       (+ (car frac)
  93.          (/ 1. (frac->number (cdr frac)))))))
  94.  
  95.